Sub TPonekey()

' Dim formulate As String
Dim dilution_times As Integer
Dim blank_absorbance As Integer
Dim absorbance As Integer

'1.指定空白吸光度位于第几列
blank_absorbance = 1

'2.指定稀释倍数位于序列工作表的第几列
dilution_times = 1

'3.指定样品吸光度数据位于第几列
absorbance = 1

' 指定收样日期、分析日期、温湿度、样品类型
Dim recv_date As String
Dim analysis_date As String
Dim tempture As String
Dim sample_type As String
recv_date = ""
analysis_date = ""
tempture = ""
sample_type = ""
'-------------------------------------------------------



' 定义不同样品编号所含关键字
Dim blank As String
Dim parallel As String
Dim QC As String
Dim staAdd As String
Dim midpoint As String

blank = "KB"
parallel = "PX"
QC = "HJ"
staAdd = "JB"
midpoint = "CCV"

' 初始化不同样品编号出现次数
Dim blank_num As Integer
Dim parallel_num As Integer
Dim QC_num As Integer
Dim staAdd_num As Integer
Dim midpoint_num As Integer
Dim sample_num As Integer

blank_num = 0
parallel_num = 0
QC_num = 0
staAdd_num = 0
midpoint_num = 0

' 定义编号数组
Dim id_array(1 To 99) As String
' 定义平行编号字典
Dim parallel_dict As Object
Set parallel_dict = CreateObject("Scripting.Dictionary")

For i = 1 To 99 Step 1

    id_array(i) = Sheets("数据").Range("A" & i).Value
    
    If checkString(id_array(i), blank) = True Then
        blank_num = blank_num + 1
    End If
    If checkString(id_array(i), parallel) = True Then
        '将平行样编号插入字典
        parallel_dict.Add i, id_array(i)
        parallel_num = parallel_num + 1
    End If
    If checkString(id_array(i), QC) = True Then
        QC_num = QC_num + 1
    End If
    If checkString(id_array(i), staAdd) = True Then
        staAdd_num = staAdd_num + 1
    End If
    If checkString(id_array(i), midpoint) = True Then
        midpoint_num = midpoint_num + 1
    End If
Next

MsgBox "blank_num:" & blank_num
MsgBox "parallel_num:" & parallel_num
MsgBox "QC_num:" & QC_num
MsgBox "staAdd_num:" & staAdd_num



End Sub

'判断是否含有keyword，传入两个参数，第一个为需要被搜索的字符串,第二个为搜索的字符串
Function checkString(string1, keyword) As Boolean
    ret = InStr(1, string1, keyword, 1)
        If ret <> 0 Then
            checkString = 1
        Else
            checkString = 0
        End If
End Function
















'id为长编号
    Dim id As String
'length为序列的长度
    Const length As Integer = 99
    Dim i As Integer
    Dim i2 As Integer
    Dim i3 As Integer
    Dim i4 As Integer
    Dim id_array(1 To length) As String
    Dim perfix, id_short As String
    Dim ret
    Dim ret2
    Dim short_id_dict As Object
    Set short_id_dict = CreateObject("scripting.dictionary")
    Dim times As Integer
    Dim start_number As Integer
    
    'times用于记录一个单的单量
    times = 0
    '每个单的编号都有此前缀，含有与否用于判断是否为单号
    perfix = "EN2021"
    
    '构建字典与数组
    For i = 1 To length Step 1
        id_array(i) = Sheets("序列").Range("A" & i).Value
        ret = InStr(1, id_array(i), perfix, 1)
        '判断是否为样品编号，是则加入字典
        If ret <> 0 Then
            '截取样品四位编号
            id_short = Mid(id_array(i), 9, 4)
            '将四位编号作为字典的键，构成不重复的值用于命名工作表
            short_id_dict(id_short) = ""
        End If
    Next
    
    '逐个建立sheet
    For Each short_id In short_id_dict.keys
    
        For i2 = LBound(id_array) To UBound(id_array)
            ret2 = InStr(1, id_array(i2), short_id, 1)
            If ret2 <> 0 Then
                start_number = i2
                '得到第一个编号开始的位置，跳出循环
                Exit For
            End If
        Next
        
        '复制第一张样表
        Sheets("temp").Copy After:=ActiveSheet
        
        '以短编号命名当前选中的工作表
        ActiveSheet.Name = short_id
        
        '计算当前short_id出现次数
        For i3 = LBound(id_array) To UBound(id_array)
            'ret2作为四位编号是否在长编号的标志，为0则不在
            ret2 = InStr(1, id_array(i3), short_id, 1)
            '判断ret2是否为0，不为零则统计出现的次数
            If ret2 <> 0 Then
                times = times + 1
            End If
        Next
        
        '依据编号出现次数，填充编号
        For i4 = 17 To times + 16 Step 1
            Range("A" & i4).Value = id_array(start_number)
            start_number = 1 + start_number
        Next
        Range("a" & (times + 17)).Value = "以下空白"
        '重置出现次数
        times = 0
    Next

End Sub